home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagn_r.zip / POINTERS.SWG / 0010_Binary Tree - Linked List.pas < prev    next >
Pascal/Delphi Source File  |  1993-08-17  |  10KB  |  378 lines
  1. Unit BinTree;
  2.  
  3. Interface
  4.  
  5. Const TOTAL_NODES = 100;
  6.  
  7. Type BTreeStr = String[40];
  8.   ShiftSet = (TiltL_Tilt, neutral, TiltR_Tilt);
  9.   BinData  = Record
  10.     Key : BTreeStr;
  11.   End;
  12.   BinPtr = ^Bin_Tree_Rec;
  13.   Bin_Tree_Rec = Record
  14.     BTreeData    : BinData;
  15.     Shift        : ShiftSet;
  16.     TiltL, TiltR : BinPtr;
  17.   End;
  18.   BTreeRec = Array[1..TOTAL_NODES] of BinData;
  19.  
  20. Procedure Ins_BinTree
  21.   (Var Rt   : BinPtr;
  22.        Node : BinData);
  23.  
  24. Function Srch_BinTree
  25.   (Rt     : BinPtr;
  26.    Node   : BinData;
  27.    Index1 : Word) : Word;
  28.  
  29. Procedure BSortArray
  30.   (Var Rt       : BinPtr;
  31.    Var SortNode : BTreeRec;
  32.    Var Index    : Word);
  33.  
  34. Procedure Del_BinTree
  35.   (Var Rt      : BinPtr;
  36.        Node    : BinData;
  37.        Var DelFlag : Boolean);
  38.  
  39. Implementation
  40.  
  41. Procedure Move_TiltR(Var Rt : BinPtr);
  42.  
  43.   Var
  44.     Ptr1, Ptr2 : BinPtr;
  45.  
  46.   Begin
  47.     Ptr1 := Rt^.TiltR;
  48.     If Ptr1^.Shift = TiltR_Tilt Then Begin
  49.       Rt^.TiltR := Ptr1^.TiltL;
  50.       Ptr1^.TiltL := Rt;
  51.       Rt^.Shift := neutral;
  52.       Rt := Ptr1
  53.     End
  54.     Else Begin
  55.       Ptr2 := Ptr1^.TiltL;
  56.       Ptr1^.TiltL := Ptr2^.TiltR;
  57.       Ptr2^.TiltR := Ptr1;
  58.       Rt^.TiltR := Ptr2^.TiltL;
  59.       Ptr2^.TiltL := Rt;
  60.       If Ptr2^.Shift = TiltL_Tilt
  61.         Then Ptr1^.Shift := TiltR_Tilt
  62.         Else Ptr1^.Shift := neutral;
  63.       If Ptr2^.Shift = TiltR_Tilt
  64.         Then Rt^.Shift := TiltL_Tilt
  65.         Else Rt^.Shift := neutral;
  66.       Rt := Ptr2
  67.     End;
  68.     Rt^.Shift := neutral
  69.   End;
  70.  
  71. Procedure Move_TiltL(Var Rt : BinPtr);
  72.  
  73.   Var
  74.     Ptr1, Ptr2 : BinPtr;
  75.  
  76.   Begin
  77.     Ptr1 := Rt^.TiltL;
  78.     If Ptr1^.Shift = TiltL_Tilt Then Begin
  79.       Rt^.TiltL := Ptr1^.TiltR;
  80.       Ptr1^.TiltR := Rt;
  81.       Rt^.Shift := neutral;
  82.       Rt := Ptr1
  83.     End
  84.     Else Begin
  85.       Ptr2 := Ptr1^.TiltR;
  86.       Ptr1^.TiltR := Ptr2^.TiltL;
  87.       Ptr2^.TiltL := Ptr1;
  88.       Rt^.TiltL := Ptr2^.TiltR;
  89.       Ptr2^.TiltR := Rt;
  90.       If Ptr2^.Shift = TiltR_Tilt
  91.         Then Ptr1^.Shift := TiltL_Tilt
  92.         Else Ptr1^.Shift := neutral;
  93.       If Ptr2^.Shift = TiltL_Tilt
  94.         Then Rt^.Shift := TiltR_Tilt
  95.         Else Rt^.Shift := neutral;
  96.       Rt := Ptr2;
  97.     End;
  98.     Rt^.Shift := neutral
  99.   End;
  100.  
  101. Procedure Ins_Bin(Var Rt    : BinPtr;
  102.                       Node  : BinData;
  103.                   Var InsOK : Boolean);
  104.  
  105.   Begin
  106.     If Rt = NIL Then Begin
  107.       New(Rt);
  108.       With Rt^ Do Begin
  109.         BTreeData := Node;
  110.         TiltL := NIL;
  111.         TiltR := NIL;
  112.         Shift := neutral
  113.       End;
  114.       InsOK := TRUE
  115.     End
  116.     Else If Node.Key <= Rt^.BTreeData.Key Then Begin
  117.       Ins_Bin(Rt^.TiltL, Node, InsOK);
  118.       If InsOK Then
  119.         Case Rt^.Shift Of
  120.           TiltL_Tilt : Begin
  121.                         Move_TiltL(Rt);
  122.                         InsOK := FALSE
  123.                        End;
  124.           neutral    : Rt^.Shift := TiltL_Tilt;
  125.           TiltR_Tilt : Begin
  126.                         Rt^.Shift := neutral;
  127.                         InsOK := FALSE
  128.                        End;
  129.         End;
  130.       End
  131.       Else Begin
  132.         Ins_Bin(Rt^.TiltR, Node, InsOK);
  133.         If InsOK Then
  134.           Case Rt^.Shift Of
  135.             TiltL_Tilt : Begin
  136.                           Rt^.Shift := neutral;
  137.                           InsOK := FALSE
  138.                          End;
  139.             neutral    : Rt^.Shift := TiltR_Tilt;
  140.             TiltR_Tilt : Begin
  141.                           Move_TiltR(Rt);
  142.                           InsOK := FALSE
  143.                          End;
  144.           End;
  145.         End;
  146.   End;
  147.  
  148. Procedure Ins_BinTree(Var Rt   : BinPtr;
  149.                         Node : BinData);
  150.  
  151.   Var Ins_ok : Boolean;
  152.  
  153.   Begin
  154.     Ins_ok := FALSE;
  155.     Ins_Bin(Rt, Node, Ins_ok)
  156.   End;
  157.  
  158. Function Srch_BinTree(Rt     : BinPtr;
  159.                       Node   : BinData;
  160.                       Index1 : Word)
  161.                       : Word;
  162.  
  163.   Var
  164.     Index : Word;
  165.  
  166.   Begin
  167.     Index := 0;
  168.     While (Rt <> NIL) AND (Index < Index1) Do
  169.       If Node.Key > Rt^.BTreeData.Key Then Rt := Rt^.TiltR
  170.       Else if Node.Key < Rt^.BTreeData.Key Then Rt := Rt^.TiltL
  171.       Else Begin
  172.         Inc(Index);
  173.         Rt := Rt^.TiltL
  174.       End;
  175.     Srch_BinTree := Index
  176.   End;
  177.  
  178. Procedure Tvrs_Tree
  179.   (Var Rt       : BinPtr;
  180.    Var SortNode : BTreeRec;
  181.    Var Index    : Word);
  182.  
  183.   Begin
  184.     If Rt <> NIL Then Begin
  185.       Tvrs_Tree(Rt^.TiltL, SortNode, Index);
  186.       Inc(Index);
  187.       If Index <= TOTAL_NODES Then
  188.         SortNode[Index].Key := Rt^.BTreeData.Key;
  189.       Tvrs_Tree(Rt^.TiltR, SortNode, Index);
  190.     End;
  191.   End;
  192.  
  193. Procedure BSortArray
  194.   (Var Rt       : BinPtr;
  195.    Var SortNode : BTreeRec;
  196.    Var Index    : Word);
  197.  
  198.   Begin
  199.     Index := 0;
  200.     Tvrs_Tree(Rt, SortNode, Index);
  201.   End;
  202.  
  203. Procedure Shift_TiltR
  204.   (Var Rt      : BinPtr;
  205.    Var DelFlag : Boolean);
  206.  
  207.   Var
  208.     Ptr1, Ptr2 : BinPtr;
  209.     balnc2, balnc3 : ShiftSet;
  210.  
  211.   Begin
  212.     Case Rt^.Shift Of
  213.       TiltL_Tilt : Rt^.Shift := neutral;
  214.       neutral    : Begin
  215.                      Rt^.Shift := TiltR_Tilt;
  216.                      DelFlag := FALSE
  217.                    End;
  218.       TiltR_Tilt : Begin
  219.            Ptr1 := Rt^.TiltR;
  220.            balnc2 := Ptr1^.Shift;
  221.            If NOT (balnc2 = TiltL_Tilt) Then Begin
  222.              Rt^.TiltR := Ptr1^.TiltL;
  223.              Ptr1^.TiltL := Rt;
  224.              If balnc2 = neutral Then Begin
  225.                Rt^.Shift := TiltR_Tilt;
  226.                Ptr1^.Shift := TiltL_Tilt;
  227.                DelFlag := FALSE
  228.              End
  229.              Else Begin
  230.                Rt^.Shift := neutral;
  231.                Ptr1^.Shift := neutral;
  232.              End;
  233.              Rt := Ptr1
  234.            End
  235.            Else Begin
  236.              Ptr2 := Ptr1^.TiltL;
  237.              balnc3 := Ptr2^.Shift;
  238.              Ptr1^.TiltL := Ptr2^.TiltR;
  239.              Ptr2^.TiltR := Ptr1;
  240.              Rt^.TiltR := Ptr2^.TiltL;
  241.              Ptr2^.TiltL := Rt;
  242.              If balnc3 = TiltL_Tilt Then
  243.                Ptr1^.Shift := TiltR_Tilt
  244.              Else
  245.                Ptr1^.Shift := neutral;
  246.              If balnc3 = TiltR_Tilt Then
  247.                Rt^.Shift := TiltL_Tilt
  248.              Else
  249.                Rt^.Shift := neutral;
  250.              Rt := Ptr2;
  251.              Ptr2^.Shift := neutral;
  252.            End;
  253.          End;
  254.       End;
  255.     End;
  256.  
  257. Procedure Shift_TiltL
  258.   (Var Rt      : BinPtr;
  259.    Var DelFlag : Boolean);
  260.  
  261.   Var
  262.     Ptr1, Ptr2 : BinPtr;
  263.     balnc2, balnc3 : ShiftSet;
  264.  
  265.   Begin
  266.     Case Rt^.Shift Of
  267.       TiltR_Tilt : Rt^.Shift := neutral;
  268.       neutral    : Begin
  269.                      Rt^.Shift := TiltL_Tilt;
  270.                      DelFlag := False
  271.                    End;
  272.       TiltL_Tilt : Begin
  273.            Ptr1 := Rt^.TiltL;
  274.            balnc2 := Ptr1^.Shift;
  275.            If NOT (balnc2 = TiltR_Tilt) Then Begin
  276.              Rt^.TiltL := Ptr1^.TiltR;
  277.              Ptr1^.TiltR := Rt;
  278.              If balnc2 = neutral Then Begin
  279.                Rt^.Shift := TiltL_Tilt;
  280.                Ptr1^.Shift := TiltR_Tilt;
  281.                DelFlag := FALSE
  282.              End
  283.              Else Begin
  284.                Rt^.Shift := neutral;
  285.                Ptr1^.Shift := neutral;
  286.              End;
  287.              Rt := Ptr1
  288.            End
  289.            Else Begin
  290.              Ptr2 := Ptr1^.TiltR;
  291.              balnc3 := Ptr2^.Shift;
  292.              Ptr1^.TiltR := Ptr2^.TiltL;
  293.              Ptr2^.TiltL := Ptr1;
  294.              Rt^.TiltL := Ptr2^.TiltR;
  295.              Ptr2^.TiltR := Rt;
  296.              If balnc3 = TiltR_Tilt Then
  297.                Ptr1^.Shift := TiltL_Tilt
  298.              Else
  299.                Ptr1^.Shift := neutral;
  300.              If balnc3 = TiltL_Tilt Then
  301.                Rt^.Shift := TiltR_Tilt
  302.              Else
  303.                Rt^.Shift := neutral;
  304.              Rt := Ptr2;
  305.              Ptr2^.Shift := neutral;
  306.            End;
  307.          End;
  308.     End;
  309.   End;
  310.  
  311. Procedure Kill_Lo_Nodes
  312.   (Var Rt,
  313.        Ptr     : BinPtr;
  314.    Var DelFlag : Boolean);
  315.  
  316.   Begin
  317.     If Ptr^.TiltR = NIL Then Begin
  318.       Rt^.BTreeData := Ptr^.BTreeData;
  319.       Ptr := Ptr^.TiltL;
  320.       DelFlag := TRUE
  321.     End
  322.     Else Begin
  323.       Kill_Lo_Nodes(Rt, Ptr^.TiltR, DelFlag);
  324.       If DelFlag Then Shift_TiltL(Ptr,DelFlag);
  325.     End;
  326.   End;
  327.  
  328. Procedure Del_Bin(Var Rt      : BinPtr;
  329.                       Node    : BinData;
  330.                   Var DelFlag : Boolean);
  331.  
  332.   Var
  333.     Ptr : BinPtr;
  334.  
  335.   Begin
  336.     If Rt = NIL Then
  337.        DelFlag := False
  338.     Else
  339.       If Node.Key < Rt^.BTreeData.Key Then Begin
  340.         Del_Bin(Rt^.TiltL, Node, DelFlag);
  341.         If DelFlag Then Shift_TiltR(Rt, DelFlag);
  342.       End
  343.       Else Begin
  344.         If Node.Key > Rt^.BTreeData.Key Then Begin
  345.           Del_Bin(Rt^.TiltR, Node, DelFlag);
  346.           If DelFlag Then Shift_TiltL(Rt, DelFlag);
  347.         End
  348.         Else Begin
  349.           Ptr := Rt;
  350.           If Rt^.TiltR = NIL Then Begin
  351.             Rt := Rt^.TiltL;
  352.             DelFlag := TRUE;
  353.             Dispose(Ptr);
  354.           End
  355.           Else If Rt^.TiltL = NIL Then Begin
  356.             Rt := Rt^.TiltR;
  357.             DelFlag := TRUE;
  358.             Dispose(Ptr);
  359.           End
  360.           Else Begin
  361.             Kill_Lo_Nodes(Rt, Rt^.TiltL, DelFlag);
  362.             If DelFlag Then Shift_TiltR(Rt, DelFlag);
  363.             Dispose(Rt^.TiltL);
  364.           End;
  365.         End;
  366.       End;
  367.   End;
  368.  
  369. Procedure Del_BinTree
  370.   (Var Rt      : BinPtr;
  371.        Node    : BinData;
  372.    Var DelFlag : Boolean);
  373.  
  374.   Begin
  375.     DelFlag := FALSE;
  376.     Del_Bin(Rt, Node, DelFlag)
  377.   End;
  378. End.